home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / hm--html-menus / adapt.el.z / adapt.el
Encoding:
Text File  |  1998-05-21  |  17.0 KB  |  491 lines
  1. ;;; $Id: adapt.el,v 3.17 1997/07/20 06:36:20 muenkel Exp $
  2. ;;;
  3. ;;; Copyright (C) 1993 - 1997  Heiko Muenkel
  4. ;;; email: muenkel@tnt.uni-hannover.de
  5. ;;;
  6. ;;;  This program is free software; you can redistribute it and/or modify
  7. ;;;  it under the terms of the GNU General Public License as published by
  8. ;;;  the Free Software Foundation; either version 2, or (at your option)
  9. ;;;  any later version.
  10. ;;;
  11. ;;;  This program is distributed in the hope that it will be useful,
  12. ;;;  but WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14. ;;;  GNU General Public License for more details.
  15. ;;;
  16. ;;;  You should have received a copy of the GNU General Public License
  17. ;;;  along with this program; if not, write to the Free Software
  18. ;;;  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  19. ;;;
  20. ;;; 
  21. ;;; Description:
  22. ;;;
  23. ;;;    General functions to port XEmacs functions to GNU Emacs 19.
  24. ;;; 
  25. ;;; Installation: 
  26. ;;;   
  27. ;;;    Put this file in one of your lisp load directories.
  28. ;;;
  29.  
  30.  
  31. (defun adapt-xemacsp ()
  32.   "Returns non nil if the editor is the XEmacs."
  33.   (or (string-match "Lucid" emacs-version)
  34.       (string-match "XEmacs" emacs-version)))
  35.  
  36.  
  37. (defun adapt-lemacsp ()
  38.   "Returns non nil if the editor is the XEmacs.
  39. Old version, use `adapt-xemacsp' instead of this."
  40.   (or (string-match "Lucid" emacs-version)
  41.       (string-match "XEmacs" emacs-version)))
  42.  
  43.  
  44. (defun adapt-emacs19p ()
  45.   "Returns non nil if the editor is the GNU Emacs 19."
  46.   (and 
  47.    (not (adapt-xemacsp))
  48.    (string= (substring emacs-version 0 2) "19")))
  49.  
  50. ;;; Functions, which don't exist in both emacs versions
  51.  
  52. (defun adapt-region-active-p ()
  53.   "Returns t, if a region is active."
  54.   (if (adapt-xemacsp)
  55.       (mark)
  56.     mark-active))
  57.  
  58. (if (not (fboundp 'file-remote-p))
  59.     (defun file-remote-p (file)
  60.       "Test wether file resides on the local system.
  61. The special value 'unknown is returned if no remote file acess package
  62. has been loaded."
  63.       (if (not (featurep 'ange-ftp))
  64.       (require 'ange-ftp))
  65.       (if (not (fboundp 'ange-ftp-ftp-p))
  66.       nil ; better than nothing, if no ange-ftp-ftp-p exists
  67.     (ange-ftp-ftp-path file))))
  68.  
  69.  
  70. ;;; Functions, which don't exist in the Emacs 19
  71. (if (adapt-emacs19p)
  72.     (progn
  73.       (load-library "lucid")
  74.  
  75.       (load-library "lmenu")
  76.  
  77.       (if window-system
  78.       (require 'font-lock)
  79.     )
  80.  
  81.       (make-face 'font-lock-comment-face)
  82.  
  83.       (defun read-number (prompt &optional integers-only)
  84.     "Reads a number from the minibuffer."
  85.     (interactive)
  86.     (let ((error t)
  87.           (number nil))
  88.       (if integers-only
  89.           (while error
  90.         (let ((input-string (read-string prompt)))
  91.           (setq number (if (string= "" input-string)
  92.                    nil
  93.                  (read input-string)))
  94.           (if (integerp number)
  95.               (setq error nil))))
  96.         (while error
  97.           (let ((input-string (read-string prompt)))
  98.         (setq number (if (string= "" input-string)
  99.                  nil
  100.                    (read input-string)))        
  101.         (if (numberp number)
  102.             (setq error nil)))))
  103.       number))
  104.  
  105.       (defvar original-read-string-function nil
  106.     "Points to the original Emacs 19 function read-string.")
  107.  
  108.       (if (not original-read-string-function)
  109.       (fset 'original-read-string-function
  110.         (symbol-function 'read-string)))
  111.  
  112.       (defun read-string (prompt &optional initial-contents history)
  113.     "Return a string from the minibuffer, prompting with string PROMPT.
  114. If non-nil, optional second arg INITIAL-CONTENTS is a string to insert
  115. in the minibuffer before reading.
  116. Third arg HISTORY, if non-nil, specifies a history list."
  117.     (read-from-minibuffer prompt initial-contents nil nil history))
  118.  
  119.       (defun make-extent (beg end &optional buffer)
  120.     (make-overlay beg end buffer))
  121.  
  122.       (defun set-extent-property (extent prop value)
  123.     (if (eq prop 'duplicable)
  124.         (cond ((and value (not (overlay-get extent prop)))
  125.            ;; If becoming duplicable, 
  126.            ;; copy all overlay props to text props.
  127.            (add-text-properties (overlay-start extent)
  128.                     (overlay-end extent)
  129.                     (overlay-properties extent)
  130.                     (overlay-buffer extent)))
  131.           ;; If becoming no longer duplicable, remove these text props.
  132.           ((and (not value) (overlay-get extent prop))
  133.            (remove-text-properties (overlay-start extent)
  134.                        (overlay-end extent)
  135.                        (overlay-properties extent)
  136.                        (overlay-buffer extent))))
  137.       ;; If extent is already duplicable, put this property
  138.       ;; on the text as well as on the overlay.
  139.       (if (overlay-get extent 'duplicable)
  140.           (put-text-property  (overlay-start extent)
  141.                   (overlay-end extent)
  142.                   prop value (overlay-buffer extent))))
  143.     (overlay-put extent prop value))
  144.       
  145.       (defun set-extent-face (extent face)
  146.     (set-extent-property extent 'face face))
  147.       
  148.       (defun delete-extent (extent)
  149.     (set-extent-property extent 'duplicable nil)
  150.     (delete-overlay extent))
  151.       
  152. ;      (defun make-extent (from to &optional buffer)
  153. ;    "Make extent for range [FROM, TO) in BUFFER -- BUFFER defaults to 
  154. ;current buffer.  Insertions at point TO will be outside of the extent;
  155. ;insertions at FROM will be inside the extent (and the extent will grow.).
  156. ;This is only a simple emulation of the Lucid Emacs extents !"
  157. ;    (list 'extent from to buffer))
  158. ;
  159. ;      (defun set-extent-face (extent face)
  160. ;    "Make the given EXTENT have the graphic attributes specified by FACE.
  161. ;This is only a simple emulation of the Lucid Emacs extents !"
  162. ;    (put-text-property (car (cdr extent))
  163. ;               (car (cdr (cdr extent)))
  164. ;               'face
  165. ;               face
  166. ;               (car (cdr (cdr (cdr extent))))))
  167. ;
  168. ;      (defun delete-extent (extent_obj)
  169. ;    "Remove EXTENT from its buffer; this does not modify the buffer's text,
  170. ;only its display properties.
  171. ;This is only a simple emulation of the Lucid Emacs extents !"
  172. ;    (remove-text-properties (car (cdr extent_obj))
  173. ;                (car (cdr (cdr extent_obj)))
  174. ;                (list 'face nil)
  175. ;                (car (cdr (cdr (cdr extent_obj))))))
  176. ;      
  177.  
  178.       (if (not (fboundp 'emacs-pid))
  179.       (defun emacs-pid ()
  180.         "Return the process ID of Emacs, as an integer.
  181. This is a dummy function for old versions of the Emacs 19.
  182. You should install a new version, which has `emacs-pid' implemented."
  183.         0)
  184.     )
  185.  
  186.       (if (not (fboundp 'facep))
  187.       (defun facep (object)
  188.         "Whether OBJECT is a FACE.
  189. It's only a dummy function in the Emacs 19, which returns always nil."
  190.         nil))
  191.       
  192. ;      (if (not (fboundp 'set-extent-property))
  193. ;      (defun set-extent-property (extent  property value)
  194. ;        "Change a property of an extent.
  195. ;Only a dummy version in Emacs 19."))
  196.  
  197.       (if (not (fboundp 'region-active-p))
  198.       (defun region-active-p ()
  199.         "Non-nil iff the region is active.
  200. If `zmacs-regions' is true, this is equivalent to `region-exists-p'.
  201. Otherwise, this function always returns false."
  202.         (adapt-region-active-p)))
  203.  
  204.       (if (not (fboundp 'next-command-event))
  205.       (defun next-command-event (&optional event prompt)
  206.         "Unlike the XEmacs version it reads the next event, if
  207. it is a command event or not.
  208.  
  209. Return the next available \"user\" event.
  210.  Pass this object to `dispatch-event' to handle it.
  211.  
  212.  If EVENT is non-nil, it should be an event object and will be filled in
  213.  and returned; otherwise a new event object will be created and returned.
  214.  If PROMPT is non-nil, it should be a string and will be displayed in the
  215.  echo area while this function is waiting for an event.
  216.  
  217.  The event returned will be a keyboard, mouse press, or mouse release event.
  218.  If there are non-command events available (mouse motion, sub-process output,
  219.  etc) then these will be executed (with `dispatch-event') and discarded.  This
  220.  function is provided as a convenience; it is equivalent to the lisp code
  221.  
  222.      (while (progn
  223.           (next-event event prompt)
  224.           (not (or (key-press-event-p event)
  225.                (button-press-event-p event)
  226.                (button-release-event-p event)
  227.                (misc-user-event-p event))))
  228.         (dispatch-event event))"
  229.         (message prompt)
  230.         (or event
  231.         (read-event))))
  232.  
  233.       (if (not (fboundp 'button-event-p))
  234.       (defun button-event-p (obj)
  235.         "True if OBJ is a button-press or button-release event object."
  236.         (and (eventp obj)
  237.          (or (eq 'mouse-1 (event-basic-type obj))
  238.              (eq 'mouse-2 (event-basic-type obj))
  239.              (eq 'mouse-3 (event-basic-type obj))
  240.              (eq 'down-mouse-1 (event-basic-type obj))
  241.              (eq 'down-mouse-2 (event-basic-type obj))
  242.              (eq 'down-mouse-3 (event-basic-type obj))
  243.              (eq 'up-mouse-1 (event-basic-type obj))
  244.              (eq 'up-mouse-2 (event-basic-type obj))
  245.              (eq 'up-mouse-3 (event-basic-type obj))
  246.              (eq 'drag-mouse-1 (event-basic-type obj))
  247.              (eq 'drag-mouse-2 (event-basic-type obj))
  248.              (eq 'drag-mouse-3 (event-basic-type obj))
  249.              ))))
  250.  
  251.       (if (not (fboundp 'button-drag-event-p))
  252.       (defun button-drag-event-p (obj)
  253.         "True if OBJ is a mouse-button-drag event object."
  254.         (and (button-event-p obj)
  255.          (member 'drag (event-modifiers obj)))))
  256.  
  257.       (if (not (fboundp 'button-press-event-p))
  258.       (defun button-press-event-p (obj)
  259.         "True if OBJ is a mouse-button-press event object."
  260.         (and (button-event-p obj)
  261.          (member 'down (event-modifiers obj)))))
  262.  
  263.       (if (not (fboundp 'button-release-event-p))
  264.       (defun button-release-event-p (obj)
  265.         "True if OBJ is a mouse-button-release event object."
  266.         (and (button-event-p obj)
  267.          (not (button-press-event-p obj)))))
  268.  
  269.       (if (not (fboundp 'button-click-event-p))
  270.       (defun button-click-event-p (obj)
  271.         "True if OBJ is a click event obkect."
  272.         ;; only for the Emacs 19
  273.         ;; doesn't exist and can't (?) exist in the XEmacs
  274.         (and (button-event-p obj)
  275.          (member 'click (event-modifiers obj)))))
  276.       
  277.       (if (not (fboundp 'mouse-event-p))
  278.       (defun mouse-event-p (obj)
  279.         "True if OBJ is a button-press, button-release, or mouse-motion event object."
  280.         (or (button-event-p obj)
  281.         (member 'drag (event-modifiers obj)))))
  282.  
  283.       (if (not (fboundp 'event-window))
  284.       (defun event-window (event)
  285.         "Return the window of the given mouse EVENT.
  286. This may be nil if the event occurred in the border or over a toolbar.
  287. The modeline is considered to be in the window it represents.
  288.  
  289. If the EVENT is a mouse drag event, then the end event window is returned."
  290.         (if (button-drag-event-p event)
  291.         (and (listp event)
  292.              (third event)
  293.              (listp (third event))
  294.              (windowp (car (third event)))
  295.              (car (third event)))
  296.           (and (eventp event)
  297.            (listp event)
  298.            (second event)
  299.            (listp (second event))
  300.            (windowp (car (second event)))
  301.            (car (second event))))))
  302.  
  303. ;           (listp (cdr event))
  304. ;           (listp (car (cdr event)))
  305. ;           (windowp (car (car (cdr event))))
  306. ;           (car (car (cdr event))))))
  307.  
  308.       (if (not (fboundp 'event-buffer))
  309.       (defun event-buffer (event)
  310.         "Given a mouse-motion, button-press, or button-release event,
  311. return the buffer on which that event occurred.  This will be nil for 
  312. non-mouse events.  If event-over-text-area-p is nil, this will also be nil."
  313.         (if (button-event-p event)
  314.         (window-buffer (event-window event)))))
  315.  
  316.  
  317.       (if (not (fboundp 'event-closest-point))
  318.       (defun event-closest-point (event)
  319.         "Return the character position of the given mouse EVENT.
  320. If the EVENT did not occur over a window or over text, return the
  321. closest point to the location of the EVENT.  If the Y pixel position
  322. overlaps a window and the X pixel position is to the left of that
  323. window, the closest point is the beginning of the line containing the
  324. Y position.  If the Y pixel position overlaps a window and the X pixel
  325. position is to the right of that window, the closest point is the end
  326. of the line containing the Y position.  If the Y pixel position is
  327. above a window, return 0.  If it is below a window, return the value
  328. of (window-end).
  329.  
  330. If the EVENT is a drag event, the event-end will be used."
  331.         (if (button-drag-event-p event)
  332.         (posn-point (event-end event))
  333.           (posn-point (event-start event)))))
  334.  
  335.       (if (not (fboundp 'add-minor-mode))
  336.       (defun add-minor-mode (toggle 
  337.                  name 
  338.                  &optional 
  339.                  keymap 
  340.                  after 
  341.                  toggle-fun)
  342.         "Add a minor mode to `minor-mode-alist' and `minor-mode-map-alist'.
  343. TOGGLE is a symbol whose value as a variable specifies whether the
  344. minor mode is active.  NAME is the name that should appear in the
  345. modeline (it should be a string beginning with a space).  KEYMAP is a
  346. keymap to make active when the minor mode is active.  AFTER is the
  347. toggling symbol used for another minor mode.  If AFTER is non-nil,
  348. then it is used to position the new mode in the minor-mode alists.
  349.  
  350. TOGGLE-FUN is only a dummy variable in the Emacs 19. In the XEmacs
  351. it has the following description:
  352. TOGGLE-FUN specifies an interactive function that is called to toggle
  353. the mode on and off; this affects what happens when button2 is pressed
  354. on the mode, and when button3 is pressed somewhere in the list of
  355. modes.  If TOGGLE-FUN is nil and TOGGLE names an interactive function,
  356. TOGGLE is used as the toggle function.
  357.  
  358. Example:  (add-minor-mode 'view-minor-mode \" View\" view-mode-map)
  359.  
  360. WARNING: THIS FUNCTION ISN'T READ YET."
  361.         (if after
  362.         (add-minor-mode-1 toggle name keymap after)
  363.           (if (not (assq toggle minor-mode-alist))
  364.           (progn
  365.             (setq minor-mode-alist
  366.               (cons (list toggle name)
  367.                 minor-mode-alist))))
  368.           (if (not (assq toggle minor-mode-map-alist))
  369.           (progn
  370.             (setq minor-mode-map-alist
  371.               (cons (cons toggle keymap)
  372.                 minor-mode-map-alist))))
  373.           ))
  374.     )
  375.  
  376.       (if (not (fboundp 'redraw-modeline))
  377.       (defalias 'redraw-modeline 'force-mode-line-update))
  378.  
  379.       (if (not (fboundp 'mouse-track))
  380.       (defalias 'mouse-track 'mouse-drag-region))
  381.  
  382.       (if (not (fboundp 'windows-of-buffer))
  383.       (defun windows-of-buffer (&optional buffer)
  384.         "Returns a list of windows that have BUFFER in them.
  385. If BUFFER is not specified, the current buffer will be used."
  386.         (get-buffer-window-list buffer)))
  387.  
  388.       (if (not (boundp 'help-selects-help-window))
  389.       (defvar help-selects-help-window t
  390.         "*If nil, use the \"old Emacs\" behavior for Help buffers.
  391. This just displays the buffer in another window, rather than selecting
  392. the window."))
  393.  
  394.       (if (not (fboundp 'with-displaying-help-buffer))
  395.       (defun with-displaying-help-buffer (thunk)
  396.         (let ((winconfig (current-window-configuration))
  397.           (was-one-window (one-window-p))
  398.           (help-not-visible
  399.            (not (and (windows-of-buffer "*Help*") ;shortcut
  400.                  (member (selected-frame)
  401.                      (mapcar 'window-frame
  402.                          (windows-of-buffer "*Help*")))))))
  403.           (prog1 (with-output-to-temp-buffer "*Help*"
  404.                (prog1 (funcall thunk)
  405.              (save-excursion
  406.                (set-buffer standard-output)
  407.                (help-mode))))
  408.         (let ((helpwin (get-buffer-window "*Help*")))
  409.           (if helpwin
  410.               (progn
  411.             (save-excursion
  412.               (set-buffer (window-buffer helpwin))
  413.               ;;If the *Help* buffer is already displayed on this
  414.               ;; frame, don't override the previous configuration
  415. ;              (if help-not-visible
  416. ;                  (set-frame-property
  417. ;                   (selected-frame)
  418. ;                   'help-window-config winconfig)))
  419.               )
  420.             (if help-selects-help-window
  421.                 (select-window helpwin))
  422.             (cond ((eq helpwin (selected-window))
  423.                    (message
  424.                 (substitute-command-keys
  425.                  "\\[scroll-up] to scroll the help."
  426.                  )))
  427.                   (was-one-window
  428.                    (message
  429.                 (substitute-command-keys
  430.                  "\\[scroll-other-window] to scroll the help."
  431.                  )))
  432.                   (t
  433.                    (message
  434.                 (substitute-command-keys
  435.                  "\\[scroll-other-window] to scroll the help."
  436.                  )))))))))))
  437.  
  438.       (if (not (fboundp 'set-extent-mouse-face))
  439.       (defun set-extent-mouse-face (extent face)
  440.         "Set the face used to highlight EXTENT when the mouse passes over it.
  441. FACE can also be a list of faces, and all faces listed will apply,
  442. with faces earlier in the list taking priority over those later in the
  443. list.
  444.  
  445. In the Emacs 19, the argument FACE could not be a list of faces."
  446.         (put-text-property (overlay-start extent)
  447.                    (overlay-end extent)
  448.                    'mouse-face face)
  449.         ))
  450.  
  451.  
  452.       (if (not (fboundp 'read-directory-name))
  453.       (defalias 'read-directory-name 'read-file-name))
  454.  
  455.       (if (not (fboundp 'define-obsolete-function-alias))
  456.       (defsubst define-obsolete-function-alias (oldfun newfun)
  457.         "Define OLDFUN as an obsolete alias for function NEWFUN.
  458. This makes calling OLDFUN equivalent to calling NEWFUN and marks OLDFUN
  459. as obsolete."
  460.         (define-function oldfun newfun)
  461.         (make-obsolete oldfun newfun)))
  462.  
  463.       (if (not (fboundp 'define-obsolete-variable-alias))
  464.       (defsubst define-obsolete-variable-alias (oldvar newvar)
  465.         "Define OLDVAR as an obsolete alias for varction NEWVAR.
  466. This makes referencing or setting OLDVAR equivalent to referencing or
  467. setting NEWVAR and marks OLDVAR as obsolete.
  468.  
  469. It is not full implemented in the Emacs 19, because of the lack of
  470. the function defvaralias.y"
  471.         ;;(defvaralias oldvar newvar) <- doesn't exist in the Emacs 19.34
  472.         (make-obsolete-variable oldvar newvar)))
  473.  
  474.       (if (not (fboundp 'defgroup))
  475.       (defmacro defgroup (symbol members doc &rest args)
  476.         "Dummy definition. Used, if the custom package isn't installed.
  477. The dummy definition makes nothing, it returns only nil."
  478.         nil))
  479.  
  480.       (if (not (fboundp 'defcustom))
  481.       (defmacro defcustom (symbol value doc &rest args)
  482.         "Simulates the defcustom definition from the custom package.
  483. It calles a `defvar' with the arguments SYMBOL, VALUE and DOC."
  484.         `(defvar ,symbol ,value ,doc)))
  485.  
  486.     
  487.       ))
  488.  
  489.  
  490. (provide 'adapt)
  491.